home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / HEAPSPY.ZIP / HWHEAP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  7.4 KB  |  268 lines
  1. {$A-,B-,E-,F-,G+,I-,K-,N-,O-,P-,Q-,R-,S-,T+,V-,W-,X+}
  2.  
  3. {**********************************************}
  4. {                                              }
  5. {   HeapSpy - HWHeap Module                    }
  6. {   Copyright (c) 1992  Borland International  }
  7. {                                              }
  8. {**********************************************}
  9.  
  10. unit HWHeap;
  11.  
  12. {$C MOVEABLE DEMANDLOAD DISCARDABLE}
  13.  
  14. interface
  15.  
  16. uses Wintypes, WinProcs, Objects, ODialogs, OWindows, BWCC, Strings,
  17.   Toolhelp, HWGlobal, HWHexDmp, HWBitmap, HWLocal, HWTPWh;
  18.  
  19. type
  20.   PHeapWin = ^THeapWin;
  21.   THeapWin = object(TSortListWin)
  22.     ModuleName: PChar;
  23.     Module: THandle;
  24.     SelectType: (ModuleHeap, All, FreeHeap);
  25.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  26.     destructor Done; virtual;
  27.     procedure BuildList; virtual;
  28.     function HandleSelect(LeftClick: Boolean): Boolean; virtual;
  29.     function GetItemString(p: pointer): PChar; virtual;
  30.     procedure DeleteItem(p: pointer); virtual;
  31.     function Less(p1,p2: pointer): integer; virtual;
  32.     procedure CMFormDump(var Msg: TMessage);
  33.       virtual cm_First + cm_FormDump;
  34.     procedure CMHexDump(var Msg: TMessage);
  35.       virtual cm_First + cm_HexDump;
  36.     procedure CMLocalWalk(var Msg: TMessage);
  37.       virtual cm_First + cm_LocalWalk;
  38.   end;
  39.  
  40. implementation
  41.  
  42. function DoTypeLit(Dest: PChar; wType,wData,hOwner: Word): PChar;
  43. var
  44.    Temp: array[0..4] of Char;
  45. begin
  46.   case wType of
  47.     gt_Resource:
  48.       begin
  49.         StrCopy(Dest,'Resource_');
  50.         StrCat(Dest,GlobalResLit[wData]);
  51.       end;
  52.     else
  53.       StrCopy(Dest, GlobalTypeLit[wType]);
  54.       StrCat(Dest, '[');
  55.       if wType <> gt_CODE then
  56.         StrCat(Dest, HexW(Temp, hOwner))
  57.       else
  58.         StrCat(Dest, HexW(Temp, wData));
  59.       StrCat(Dest, ']');
  60.    end;
  61.  DoTypeLit := Dest;
  62. end;
  63.  
  64. procedure ChangeTypes(var G: TGlobalEntry);
  65. var
  66.   SB: pTPWSubBlock;
  67. begin
  68.   if G.wType = gt_unknown then
  69.   begin
  70.     SB := PtrFromHandle(G.hBlock);
  71.     if SB <> nil then
  72.       with SB^ do
  73.         if (Signature = $5054) and ((reserved1 or reserved2) = 0) and
  74.           (FreeList < G.dwBlockSize) and (MemFree <= G.dwBlockSize) then
  75.             G.wType := gt_TPWHeap;
  76.   end;
  77. end;
  78.  
  79.  
  80.  
  81.  
  82. destructor THeapWin.Done;
  83. begin
  84.   StrDispose(ModuleName);
  85.   Inherited Done;
  86. end;
  87.  
  88. constructor THeapWin.Init;
  89. var Modl: TModuleEntry;
  90. begin
  91.  ModuleName := StrNew(ATitle);
  92.  if StrLComp(ModuleName,'All',3) = 0 then
  93.     SelectType := All
  94.  else
  95.  if StrLComp(ModuleName,'Free',4) = 0 then
  96.     SelectType := FreeHeap
  97.  else
  98.     begin
  99.     SelectType := ModuleHeap;
  100.     Modl.dwSize := Sizeof(TModuleEntry);
  101.     Modl.szModule[0] := #0;
  102.     Module := ModuleFindName(@Modl,ModuleName);
  103.     if Module = 0 then fail;
  104.     end;
  105.  Inherited Init(AParent, ATitle,true);
  106. end;
  107.  
  108. procedure THeapWin.BuildList;
  109. var
  110.   Globl: TGlobalEntry;
  111.   GP: PGlobalEntry;
  112. begin
  113.   SetCursor(WaitCursor);
  114.   Globl.dwSize := sizeof(TGlobalEntry);
  115.   GlobalFirst(@Globl,GLOBAL_ALL);
  116.   repeat
  117.     ChangeTypes(Globl);
  118.     With Globl do
  119.      if ((SelectType = ModuleHeap) and
  120.         ((hOwner = Module) or IsTaskOf(hOwner,Module))) or
  121.         ((SelectType = FreeHeap) and (hOwner = 0)) or
  122.         (SelectType = All) then
  123.      begin
  124.        New(GP);
  125.        Move(Globl,GP^,Sizeof(TGlobalEntry));
  126.        List^.AddString(PChar(GP));
  127.      end;
  128.    until not GlobalNext(@Globl,GLOBAL_ALL);
  129.    SetCursor(ArrowCursor);
  130. end;
  131.  
  132. function THeapWin.Less(p1,p2: pointer): integer;
  133. var
  134.   GL1: PGlobalEntry absolute p1;
  135.   GL2: PGlobalEntry absolute p2;
  136.   Key1, Key2: LongInt;
  137. begin
  138.  Case SortOpt of
  139.    cm_sbAddress: begin Key1 := Gl1^.dwAddress;   Key2 := GL2^.dwAddress;   end;
  140.    cm_sbHandle: begin Key1 := GL1^.hBlock;      Key2 := GL2^.hBlock;      end;
  141.    cm_sbSize  : begin Key1 := GL1^.dwBlockSize; Key2 := GL2^.dwBlockSize; end;
  142.    cm_sbType  : begin Key1 := (LongInt(GL1^.wType) shl 16) or GL1^.wdata;
  143.                        Key2 := (LongInt(GL2^.wType) shl 16) or GL2^.wdata; end;
  144.    cm_sbModule: begin Key1 := GL1^.hOwner;      Key2 := GL2^.hOwner;      end;
  145.  end;
  146.  Less := Compare32(Key1,Key2);
  147. end;
  148.  
  149. function THeapWin.GetItemString(p: pointer): PChar;
  150. var
  151.   GL: PGlobalEntry absolute p;
  152.   ListString: array[0..127] of Char;
  153.   Temp: array[0..80] of Char;
  154.   NumStr: array[0..20] of Char;
  155.   HexTemp: array[0..4] of Char;
  156.   ModuleN: array[0..10] of Char;
  157.   FlagsStr: array[0..5] of Char;
  158. begin
  159.   with GL^ do
  160.   begin
  161.     StrCopy(FlagsStr,'     ');
  162.     if wcLock=1 then FlagsStr[0] := 'L';
  163.     if wcPageLock = 1 then FlagsStr[2] := 'P';
  164.     if wHeapPresent then FlagsStr[4] := 'H';
  165.     HexL(ListString,LongInt(dwAddress));
  166.     StrCat(ListString,' ');
  167.     StrCat(ListString,HexW(HexTemp,hBlock));
  168.     StrCat(ListString,'  ');
  169.     StrCat(ListString,FlagsStr);
  170.     DoTypeLit(Temp,wType,wData,hOwner);
  171.     Str(dwBlockSize:10,NumStr);
  172.     StrCat(ListString,NumStr);
  173.     StrCat(ListString,'  ');
  174.     if SelectType = All then
  175.     begin
  176.       GetModuleName(hOwner,ModuleN);
  177.       StrPad(ModuleN,9);
  178.       StrCat(ListString,ModuleN);
  179.     end;
  180.     StrCat(ListString,Temp);
  181.     GetItemString := StrNew(ListString);
  182.   end;
  183. end;
  184.  
  185. procedure THeapWin.DeleteItem;
  186. begin
  187.   Freemem(p,Sizeof(TGlobalEntry));
  188. end;
  189.  
  190. function THeapWin.HandleSelect(LeftClick: Boolean): Boolean;
  191. var
  192.   GP: PGlobalEntry;
  193.   Msg: TMessage;
  194. begin
  195.   HandleSelect := true;
  196.   GP := PGlobalEntry(SendMEssage(List^.hWindow,LB_GETITEMDATA,List^.GetSelIndex,0));
  197.   With Application^,GP^ do
  198.   if (hBlock <> 0) then
  199.     begin
  200.     if (not LeftClick) then
  201.        begin
  202.        if wHeapPresent or (wType = gt_TPWHeap) then
  203.           CMLocalWalk(Msg)
  204.        else if (wType = gt_Resource) and (wData=GD_BitMap) then
  205.           CMFormDump(Msg)
  206.        else
  207.           CMHexDump(Msg);
  208.        end
  209.     else
  210.        CMHexDump(Msg);
  211.     end;
  212. end;
  213.  
  214. procedure THeapWin.CMLocalWalk;
  215. var
  216.   i: integer;
  217.   GP: PGlobalEntry;
  218.   MN: array[0..10] of Char;
  219. begin
  220.   i := List^.GetSelIndex;
  221.   if i < 0 then exit;
  222.   GP := PGlobalEntry(SendMEssage(List^.hWindow,LB_GETITEMDATA,i,0));
  223.   With Application^,GP^ do
  224.      if wHeapPresent or (wType = gt_TPWHEap) then
  225.         begin
  226.         GetModuleName(hOwner,MN);
  227.         if wType = gt_TPWHeap then
  228.            MakeWindow(New(pTPWHeap,Init(MainWindow,hBlock,MN)))
  229.         else
  230.            MakeWindow(New(PLocalWin,Init(MainWindow,hBlock,MN)));
  231.         end
  232.      else
  233.         BWCCMessageBox(hWindow,'No local heap present',nil,MB_ICONSTOP or MB_OK);
  234. end;
  235.  
  236. procedure THeapWin.CMHexDump;
  237. var
  238.   i: integer;
  239.   GP: PGlobalEntry;
  240.   MN: array[0..10] of Char;
  241. begin
  242.   i := List^.GetSelIndex;
  243.   if i < 0 then exit;
  244.   GP := PGlobalEntry(SendMEssage(List^.hWindow,LB_GETITEMDATA,i,0));
  245.   With Application^,GP^ do
  246.      if (hBlock <> 0) then
  247.         if MakeWindow(New(PHexDmpWin,Init(MainWindow,hBlock,0,dwBlockSize))) = nil then
  248.            BWCCMessageBox(hWindow,'Unable to lock block',nil,MB_ICONSTOP or MB_OK);
  249. end;
  250.  
  251. procedure THeapWin.CMFormDump;
  252. var
  253.   i: integer;
  254.   GP: PGlobalEntry;
  255.   MN: array[0..10] of Char;
  256. begin
  257.   i := List^.GetSelIndex;
  258.   if i < 0 then exit;
  259.   GP := PGlobalEntry(SendMEssage(List^.hWindow,LB_GETITEMDATA,i,0));
  260.   With Application^,GP^ do
  261.      if (wType = gt_Resource) and (wData=GD_BitMap) then
  262.         MakeWindow(New(PBitmapWin,Init(MainWindow,@Self,hBlock)))
  263.      else
  264.         BWCCMessageBox(hWindow,'Can''t format this block type',nil,MB_ICONSTOP or MB_OK);
  265. end;
  266.  
  267. end.
  268.